COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 spide1.lsp[f81,jmc]	spider player and referee
C00014 ENDMK
C⊗;
;;; spide1.lsp[f81,jmc]	spider player and referee
;;; We now regard this version
;;; as too ad hoc and hope to replace it by a version based on
;;; the routines in move.lsp[f81,jmc] which move objects from one
;;; pile to another and (we hope) can be used for any kind of
;;; solitaire including games like nim and Tower of Hanoi or for
;;; the simulation of systems with movable physical objects.

;;; A position is represented by the values of variables HAND and DOWN.
;;; HAND lists the cards with the next card to be played at the top.
;;; DOWN is a list of ten lists.  The break between visible and hidden
;;; cards is marked by the presence of the atom NIL in the list.
;;; A card is a list (suit denomination)

;;; The functions are:
;;; (display) prints the visible cards

(defun display () (disp1 DOWN 1))

(defun disp1 (u k) (if (null u)
		       nil
		       (prog1 (disp2 (car u) k) (disp1 (cdr u) (add1 k)))))

(defun disp2 (u k) (progn (print (cons k (disp3 u))) (blank)))

(defun disp3 (v) (if (null v)
		     nil
		     (null (car v))
		     (list (length (cdr v)))
		     (cons (car v) (disp3 (cdr v)))))

(defun blank () nil)

(setq base (setq ibase 10.))

(setq suits '(C D H S))

(setq denoms '(1 2 3 4 5 6 7 8 9 10 11 12 13))

(defun cartesian (u v)
       (mapappend
	(function (lambda (x) (mapcar
			       (function (lambda (y) (list x y)))
			       v)))
	u))

(defun mapappend (f u) (if (null u) nil (append (funcall f (car u))
						(mapappend f (cdr u)))))


(setq ideck (append (cartesian suits denoms) (cartesian suits denoms)))

(defun restart () (prog (n u)
		(setq HAND (shuffle ideck))
		(setq DOWN nil)
		(setq n 10)
a
                (if (equal n 0) (go done))
		(setq u (take (if (lessp n 7) 5 6)))
		(setq DOWN (cons (cons (car u) (cons nil (cdr u))) DOWN))
		(setq n (sub1 n))
		(go a)
done
                (display)
		(return (blank))))

(defun take (n) (prog (n1 u)
		      (setq n1 n)
		      (setq u nil)
a
                      (if (equal n1 0) (return u))
		      (setq u (cons (car HAND) u))
		      (setq HAND (cdr HAND))
		      (setq n1 (sub1 n1))
		      (go a)))

;;; shuffles a list in random order
(defun shuffle (u)
       (if (or (null u) (null (cdr u)))
	   u
	   (shuffle1 u nil nil)))
(defun shuffle1 (u w1 w2)
       (if (null u)
	   (append (shuffle w1) (shuffle w2))
	   (= 0 (random 2))
	   (shuffle1 (cdr u) (cons (car u) w1) w2)
	   (shuffle1 (cdr u) w1 (cons (car u) w2))
	   ))


;;; called by move
(defun rev1 (u v) (if (null u) v (rev1 (cdr u) (cons (car u) v))))

(defun move (i j) (prog (;sourcepile
;			 destpile
;			 destrank
;			 sourcerank
;			 sourcesuit 
;			 nmove
;			 tomove
;			 u
;			 newsource
;			 newdest
			 )

	(if (or (= i j) (< i 1) (< j 1) (< 10 i) (< 10 j)) (return 'i1))
	(setq sourcepile (nth (sub1 i) down))
	(setq destpile (nth (sub1 j) down))
	(if (null sourcepile) (return 'i2))
	(setq sourcerank (rank (car sourcepile)))
	(setq sourcesuit (suit (car sourcepile)))
	(setq nmove 1)
	(setq u sourcepile)
	(setq tomove nil)
	(if (null destpile) (go emptydest))
	(setq destrank (rank (car destpile)))
	(if (not (lessp sourcerank destrank)) (return 'i3))
loop
	(if (or (null u)
		(null (car u))
		(not (eq (suit (car u)) sourcesuit))
		(not (equal (rank (car u)) sourcerank)))
	    (return 'i4))
	(setq sourcerank (add1 sourcerank))
	(setq tomove (cons (car u) tomove))
	(setq u (cdr u))
	(setq nmove (add1 nmove))
	(if (not (equal sourcerank destrank)) (go loop))
moveit
	(setq newsource (if (null u)
			    nil
			    (null (car u))
			    (cons (cadr u) (if (null (cddr u))
					       nil
					       (cons nil (cddr u))))
			    u))
	(setq newdest (rev1 tomove destpile))
;;; update DOWN
	(setq DOWN (update DOWN 1))
	(return (display))
emptydest
eloop
	(if (or (null u)
		(null (car u))
		(not (eq (suit (car u)) sourcesuit))
		(not (equal (rank (car u)) sourcerank)))
	    (go moveit))
	(setq sourcerank (add1 sourcerank))
	(setq tomove (cons (car u) tomove))
	(setq u (cdr u))
	(setq nmove (add1 nmove))
	(go eloop)

	))

(defun update (u k)
	(if (null u)
	    nil
	    (equal k i)
	    (cons newsource (update (cdr u) (add1 k)))
	    (equal k j)
	    (cons newdest (update (cdr u) (add1 k)))
	    (cons (car u) (update (cdr u) (add1 k)))
	    ))

(defun suit (x) (car x))

(defun rank (x) (cadr x))

(defun deal () (progn
       (setq DOWN (mapcar (function
			   (lambda (v)
				   (cons (car (take 1)) v))) DOWN)) (display)))

(defun remove (n)
       (prog ()
	     (setq pile (nth down (sub1 n)))
	     (if (null pile) (return 'null_pile))
	     (setq suit (suit (car pile)))
	     (setq i 1)
loop         (if (> i 13) (go removeit))
             (if (not (and (eq (suit (car pile)) suit)
			   (= (rank (car pile)) i)))
		 (return 'incomplete))
	     (setq i (add1 i))
	     (setq pile (cdr pile))
	     (go loop)
removeit
	(setq newsource (if (null pile)
			    nil
			    (null (car pile))
			    (cons (cadr pile) (if (null (cddr pile))
					       nil
					       (cons nil (cddr pile))))
			    pile))
             (setq i n)
	     (setq j 20)
	     (setq DOWN (update down 1))
	     (return (display))
	     ))